Libris Britannia 4/science library(b).zip/science library(b)/DDJMAG/DDJ9310.ZIP/1993-OCT.ZIP/ALLEY.ASC

Text File | 1993-09-17 | 5KB | 174 lines

_ALGORITHM ALLEY_
by Tom Swan

[LISTING ONE]

(* ----------------------------------------------------------- *(
**  sample.pas -- Algorithm #12: Selection Sampling            **
** ------------------------------------------------------------**
**  Creates a file SAMPLE.DAT with a specified number of names **
**  extracted from Grady Ward's Moby Words. The first line of  **
**  the output file indicates the number of selections.        **
**  Assumes the number of names in the source is known.        **
**  Reference: Knuth, Vol 2, p122                              **
** ------------------------------------------------------------**
**     Copyright (c) 1993 by Tom Swan. All rights reserved.    **
)* ----------------------------------------------------------- *)

program Sample;
const
  M = 21420;  { Number of records in source }
  INFNAME = 'g:\moby\words\21400nam';  { Source file }
  OUTFNAME = 'sample.dat'; { Destination file }
var
  infile, outfile: Text;  { File variables }
  word: String;           { Holds each record from source }
  requested,              { Requested number of samples }
  examined,               { Total records examined }
  selected: Integer;      { Total records selected }
  r: Real;                { Random number 0 <= r < 1.0 }
begin
  Randomize;
  Writeln('Write selected names to ', OUTFNAME);
  Write('How many names? ');
  Readln(requested);
  if (requested <= 0) or (requested > M) then
  begin
    Writeln('Number must be >= 0 and <= ', M);
    Exit
  end;
  examined := 0;
  selected := 0;
  Assign(infile, INFNAME);
  Reset(infile);
  Assign(outfile, OUTFNAME);
  Rewrite(outfile);
  Writeln(outfile, requested);  { Save 'requested' in file }
  while (selected < requested) (* and (not Eof(infile)) *) do
  begin
    examined := examined + 1;
    r := Random;
    if (M - examined) * r >= requested - selected
    then
      Readln(infile)             { Skip next record }
    else
    begin                        { Select next record }
      selected := selected + 1;  { Count selections so far }
      Readln(infile, word);      { Read record from source }
      Writeln(outfile, word);    { Write record to destination }
      Writeln(word)              { Echo selection to display }
    end
  end;
  Close(infile);
  Close(outfile)
end.


[LISTING TWO]

(* ----------------------------------------------------------- *(
**  pairings.pas -- Select sports-event team pairings          **
** ------------------------------------------------------------**
**   This program generates team pairings for sports events.   **
**   Each team is guaranteed to play each other team exactly   **
**   once. No team will play more than one game per day.       **
**   An asterisk ('*') means a day off for that team.          **
**   For example, 5 teams produces this output:                **
**     Day 1 - 12 34 5*                                        **
**     Day 2 - 13 25 4*                                        **
**     Day 3 - 14 2* 35                                        **
**     Day 4 - 15 3* 24                                        **
**     Day 5 - 1* 45 23                                        **
** ------------------------------------------------------------**
**   Copyright (c) 1993 by Jim Mischel. All rights reserved.   **
)* ----------------------------------------------------------- *)

program pairings;
const
  TEAMCOUNT = 5;
var
  TeamNames: Array [1 .. TEAMCOUNT + 1] of Char;
  SwapArray: Array [1 .. TEAMCOUNT + 1] of Integer;
  x, Temp, Day: Integer;
  TempChar: Char;
const
  NTeams: Integer = TEAMCOUNT;
begin
{ Set up team names. Normally read from a file. }
  for x := 1 to NTeams do
    TeamNames[x] := Chr(x + Ord('0'));
  if Odd(NTeams) then
  begin
    NTeams := NTeams + 1;
    TeamNames[NTeams] := '*'
  end;
{ Set up the array that controls swapping. }
  for x := 1 to NTeams do
    SwapArray[x] := x;
  for Day := 1 to NTeams - 1 do
  begin
    Write('Day ', Day, ' -');
{ Write the team pairings for this day }
    x := 1;
    while x < NTeams do
    begin
      Write(' ', TeamNames[x], TeamNames[x + 1]);
      x := x + 2;
    end;
    WriteLn;
{ Perform swaps to prepare array for next day's pairings. }
    if Odd(Day)
      then x := 2
      else x := 3;
    while x < NTeams do
    begin
      TempChar := TeamNames[SwapArray[x]];
      TeamNames[SwapArray[x]] := TeamNames[SwapArray[x + 1]];
      TeamNames[SwapArray[x + 1]] := TempChar;
      Temp := SwapArray[x];
      SwapArray[x] := SwapArray[x + 1];
      SwapArray[x + 1] := Temp;
      x := x + 2
    end
  end
end.


Example 1:

const
  M = 1000;  { Input records }
  N = 128;   { Subset (N <= M) }
var
  requested,
  examined,
  selected: Integer;
  r: Real;
begin
  requested <- N;
  examined <- 0;
  selected <- 0;
  while (selected < requested) do
  begin
    examined <- examined + 1;
    r <- Random;
    if (M - examined) * r
      >= (requested - selected)
      then skip next input record
    else begin
      selected <- selected + 1;
      use next input record
    end
  end
end.



Example 2:

for x <- 1 to NTeams - 1 do
  for y <- x + 1 to NTeams do
    write(x, '-', y, ',');